home *** CD-ROM | disk | FTP | other *** search
Text File | 1994-01-06 | 35.6 KB | 658 lines | [TEXT/MPS ] |
- /* --------------------------------------------------------------------------
- * runtime.c: Copyright (c) Mark P Jones 1991-1993. All rights reserved.
- * See goferite.h for details and conditions of use etc...
- * Gofer Compiler version 1.00 January 1992
- * Gofer version 2.28 January 1993
- *
- * Runtime system for compiled Gofer programs ... uses a considerably
- * simplified runtime system than required in the full interpreter.
- * ------------------------------------------------------------------------*/
-
- #define NEED_MATH
- #include "gofc.h"
-
- /* --------------------------------------------------------------------------
- * Static data areas:
- * ------------------------------------------------------------------------*/
-
- static int keep_argc; /* keep record of command line */
- static char **keep_argv; /* arguments */
-
- static Cell consCharArray[NUM_CHARS]; /* array of ((:) c) for each char c*/
-
- static Cell resps = 0; /* pointer to list of responses */
-
- /* --------------------------------------------------------------------------
- * Local function prototypes:
- * ------------------------------------------------------------------------*/
-
- static Void evalString Args((Cell));
-
- static Cell openFile Args((String));
- static Void evalFile Args((Cell));
- static Void closeFile Args((Int));
-
- static Void dialogue Args((Cell));
- static Void readFile Args((Void));
- static Void writeFile Args((Void));
- static Void appendFile Args((Void));
- static Void readChan Args((Void));
- static Void appendChan Args((Void));
- static FILE *validOutChannel Args((String));
- static Void echo Args((Void));
- static Void getArgs Args((Void));
- static Void getProgName Args((Void));
- static Void getEnv Args((Void));
- static Void outputString Args((FILE *,Cell));
- static String evalName Args((Cell));
-
- static Int compare Args((Void));
-
- static Void primInit Args((Void));
- static Void primMark Args((Void));
-
- static sigProto(onBreak);
-
- static Void abandon Args((String) ----------------------------------------------------------
- * Integer arithmetic primitives:
- * ------------------------------------------------------------------------*/
-
- static comb2(pr_PlusInt) /* integer addition primitive */
- { Int x;
- eval(offset(2));
- x = whnfInt;
- eval(offset(1));
- heap(1);
- update(0,mkInt(x+whnfInt));
- ret();
- }
- End
-
- static comb2(pr_MinusInt) /* integer subtraction primitive */
- { Int x;
- eval(offset(2));
- x = whnfInt;
- eval(offset(1));
- heap(1);
- update(0,mkInt(x-whnfInt));
- ret();
- }
- End
-
- static comb2(pr_MulInt) /* integer multiplication primitive*/
- { Int x;
- eval(offset(2));
- x = whnfInt;
- eval(offset(1));
- heap(1);
- update(0,mkInt(x*whnfInt));
- ret();
- }
- End
-
- static comb2(pr_DivInt) /* integer division primitive */
- { Int x,y; /* truncate towards -ve infinity */
- eval(offset(2));
- x = whnfInt;
- eval(offset(1));
- if (whnfInt==0)
- abandon("division by zero");
- heap(1);
- y = x%whnfInt;
- x = x/whnfInt;
- if ((y<0 && whnfInt>0) || (y>0 && whnfInt<0))
- x--;
- update(0,mkInt(x));
- ret();
- }
- End
-
- static comb2(pr_QuotInt) /* integer division primitive */
- { Int x; /* truncated towards zero */
- eval(offset(2));
- x = whnfInt;
- eval(offset(1));
- if (whnfInt==0)
- abandon("division by zero");
- heap(1);
- update(0,mkInt(x/whnfInt));
- ret();
- }
- End
-
- static comb2(pr_ModInt) /* integer modulo primitive */
- { Int x,y;
- eval(offset(2));
- x = whnfInt;
- eval(offset(1));
- if (whnfInt==0)
- abandon("division by zero");
- heap(1);
- y = x%whnfInt; /* "... the modulo having the sign */
- if ((y<0 && whnfInt>0) || /* of the divisor ..." */
- (y>0 && whnfInt<0)) { /* See definition on p.81 of */
- update(0,mkInt(y+whnfInt)); /* Haskell report... */
- }
- else {
- update(0,mkInt(y));
- }
- ret();
- }
- End
-
- static comb2(pr_RemInt) /* integer remainder primitive */
- { Int x;
- eval(offset(2)); /* div and rem satisfy: */
- x = whnfInt; /* (x `div` y)*y+(x `rem` y) == x */
- eval(offset(1)); /* which is exactly the property */
- if (whnfInt==0) /* described in K&R 2: */
- abandon("division by zero"); /* (a/b)*b + a%b == a */
- heap(1);
- update(0,mkInt(x%whnfInt));
- ret();
- }
- End
-
- static comb1(pr_NegInt) /* integer negation primitive */
- eval(offset(1));
- heap(1);
- update(0,mkInt(-whnfInt));
- ret();
- End
-
- /* --------------------------------------------------------------------------
- * Coercion primitives:
- * ------------------------------------------------------------------------*/
-
- static comb1(pr_CharToInt) /* character to integer conversion */
- eval(offset(1));
- heap(1);
- update(0,mkInt(charOf(whnf)));
- ret();
- End
-
- static comb1(pr_IntToChar) /* integer to character conversion */
- eval(offset(1));
- if (whnfInt<0 || whnfInt>=NUM_CHARS)
- abandon("character out of range");
- update(0,mkChar(whnfInt));
- ret();
- End
-
- static comb1(pr_IntToFloat) /* integer to float primitive */
- eval(offset(1));
- heap(1);
- update(0,mkFloat((Float)(whnfInt)));
- ret();
- End
-
- /* --------------------------------------------------------------------------
- * Float arithmetic primitives:
- * ------------------------------------------------------------------------*/
-
- static comb2(pr_PlusFloat) /* float addition primitive */
- { Float x;
- eval(offset(2));
- x = floatOf(whnf);
- eval(offset(1));
- heap(1);
- update(0,mkFloat(x+floatOf(whnf)));
- ret();
- }
- End
-
- static comb2(pr_MinusFloat) /* float subtraction primitive */
- { Float x;
- eval(offset(2));
- x = floatOf(whnf);
- eval(offset(1));
- heap(1);
- update(0,mkFloat(x-floatOf(whnf)));
- ret();
- }
- End
-
- static comb2(pr_MulFloat) /* float multiplication primitive */
- { Float x;
- eval(offset(2));
- x = floatOf(whnf);
- eval(offset(1));
- heap(1);
- update(0,mkFloat(x*floatOf(whnf)));
- ret();
- }
- End
-
- static comb2(pr_DivFloat) /* float division primitive */
- { Float x;
- eval(offset(2));
- x = floatOf(whnf);
- eval(offset(1));
- if (floatOf(whnf)==0)
- abandon("float division by zero");
- heap(1);
- update(0,mkFloat(x/floatOf(whnf)));
- ret();
- }
- End
-
- static comb1(pr_NegFloat) /* float negation primitive */
- eval(offset(1));
- heap(1);
- update(0,mkFloat(-floatOf(whnf)));
- ret();
- End
-
- #if HAS_FLOATS
- #define FPRIM(n,f) static comb1(n) \
- eval(offset(1)); \
- heap(1); \
- update(0,safeMkFloat(f(floatOf(whnf))));\
- ret(); \
- End
- FPRIM(pr_SinFloat,sin) /* floating point math prims */
- FPRIM(pr_CosFloat,cos)
- FPRIM(pr_TanFloat,tan)
- FPRIM(pr_AsinFloat,asin)
- FPRIM(pr_AcosFloat,acos)
- FPRIM(pr_AtanFloat,atan)
- FPRIM(pr_LogFloat,log) /* one day, I should expand these */
- FPRIM(pr_Log10Float,log10) /* to ensure the argument is > 0 */
- FPRIM(pr_ExpFloat,exp)
- FPRIM(pr_SqrtFloat,sqrt)
- #undef FPRIM
-
- static comb2(pr_Atan2Float) /* arc tan with quadrant info */
- { Float x;
- eval(offset(2));
- x = floatOf(whnf);
- eval(offset(1));
- heap(1);
- update(0,mkFloat(atan2(x,floatOf(whnf))));
- ret();
- }
- End
-
- static comb1(pr_FloatToInt) /* convert floating point to int */
- eval(offset(1)); /* :: Float -> Int */
- heap(1);
- update(0,mkFloat((Float)(whnfInt)));
- ret();
- End
- #endif
-
- /* --------------------------------------------------------------------------
- * Comparison primitives:
- * ------------------------------------------------------------------------*/
-
- static comb2(pr_EqInt) /* integer equality primitive */
- { Int x;
- eval(offset(2));
- x = whnfInt;
- eval(offset(1));
- update(0,(x==whnfInt ? cfunTrue : cfunFalse));
- ret();
- }
- End
-
- static comb2(pr_LeInt) /* integer <= primitive */
- { Int x;
- eval(offset(2));
- x = whnfInt;
- eval(offset(1));
- update(0,(x<=whnfInt ? cfunTrue : cfunFalse));
- ret();
- }
- End
-
- static comb2(pr_EqChar) /* character equality primitive */
- { Cell x;
- eval(offset(2));
- x = whnf;
- eval(offset(1));
- update(0,(x==whnf ? cfunTrue : cfunFalse));
- ret();
- }
- End
-
- static comb2(pr_LeChar) /* character <= primitive */
- { Cell x;
- eval(offset(2));
- x = whnf;
- eval(offset(1));
- update(0,(x<=whnf ? cfunTrue : cfunFalse));
- ret();
- }
- End
-
- static comb2(pr_EqFloat) /* float equality primitive */
- { Float x;
- eval(offset(2));
- x = floatOf(whnf);
- eval(offset(1));
- update(0,(x==floatOf(whnf) ? cfunTrue : cfunFalse));
- ret();
- }
- End
-
- static comb2(pr_LeFloat) /* float <= primitive */
- { Float x;
- eval(offset(2));
- x = floatOf(whnf);
- eval(offset(1));
- update(0,(x<=floatOf(whnf) ? cfunTrue : cfunFalse));
- ret();
- }
- End
-
- /* --------------------------------------------------------------------------
- * Generic comparison primitives:
- *
- * The following primitives are provided for the benefit of anyone that
- * wants to use Gofer's generic comparison functions in place of the
- * type class alternative. Be warned however, that an attempt to compare
- * two function values using these routines will generate a runtime error
- * which will not be trapped unless you compile the runtime system and
- * application with ARGCHECK=1 (in which case, the overall performance
- * will degrade, even if you never actually do compare function values).
- * You see, using type classes really can bring benefits ... :-)
- *
- * (The hardest thing in the following code is ensuring that all of the
- * appropriate temporary variables stay on the stack to ensure proper
- * operation of the garbage collector.)
- * ------------------------------------------------------------------------*/
-
- #define LT 0
- #define EQ 1
- #define GT 2
-
- static Int compare() { /* Shared auxiliary function */
- StackPtr args = sp; /* for generic comparisons */
- Int xy;
-
- pushed(1) = pair(pushed(1),cfunNil);/* turn arguments into lists */
- pushed(0) = pair(pushed(0),cfunNil);/* simulating depth-first stack */
-
- do {
- Int xdepth, ydepth;
-
- eval(fst(pushed(0))); /* evaluate part of `x' */
- push(whnf);
- xdepth = pushedSince(args);
-
- eval(fst(pushed(1+xdepth))); /* evaluate part of `y' */
- push(whnf);
- ydepth = pushedSince(args) - xdepth;
-
- xy = xdepth+ydepth; /* discard values on top of depth- */
- pushed(xy) = snd(pushed(xy)); /* first stacks */
- pushed(xy+1) = snd(pushed(xy+1));
-
- /* If the whnf of the part of x is X x1 ... xn
- * and the whnf of the part of y is Y y1 ... ym,
- * then the top of the stack will look like this:
- *
- * top() = Y \
- * y1 |
- * . | ydepth elements
- * . |
- * ym /
- * X \
- * x1 |
- * . | xdepth elements
- * . |
- * xn /
- * xs
- * ys
- */
-
- if (isPair(top()) || isPair(pushed(ydepth))) {
- if (isPair(top()) && fst(top())==FLOATCELL) { /* Floats */
- Float xf = floatOf(pushed(ydepth));
- Float yf = floatOf(top());
- if (xf<yf) return LT;
- if (xf>yf) return GT;
- }
- else { /* Ints */
- Int xi = intOf(pushed(ydepth));
- Int yi = intOf(top());
- if (xi<yi) return LT;
- if (xi>yi) return GT;
- }
- }
- else { /* two proper constructor applics */
- if (top()>pushed(ydepth)) /* x structure has smaller constr */
- return LT;
- if (top()<pushed(ydepth)) /* y structure has smaller constr */
- return GT;
- if (xdepth!=ydepth)
- abandon("type error in comparison");
- else {
- Int i;
- for (i=ydepth-1; i>0; --i) { /* add new values */
- pushed(xy+1) = pair(pushed(i),pushed(xy+1));
- pushed(xy) = pair(pushed(i+ydepth),pushed(xy));
- }
- }
- }
- sp = args;
- } while (isPair(top())); /* loop if value queue not empty*/
-
- return EQ; /* everything matched, so x==y */
- }
-
- #define genericPrim(n,bool) static comb2(n) \
- update(0,bool ? cfunTrue : cfunFalse); \
- ret(); \
- End
- genericPrim(pr_GenericEq, compare()==EQ)
- genericPrim(pr_GenericNe, compare()!=EQ)
- genericPrim(pr_GenericLt, compare()==LT)
- genericPrim(pr_GenericLe, compare()!=GT)
- genericPrim(pr_GenericGt, compare()==GT)
- genericPrim(pr_GenericGe, compare()!=LT)
- #undef genericPrim
-
- /* --------------------------------------------------------------------------
- * Print primitives:
- * ------------------------------------------------------------------------*/
-
- static comb3(pr_ShowsInt) /* find string rep. for integer */
- { Int num; /* :: Int -> Int -> ShowS */
- drop(); /* throw away first parameter */
- eval(pop());
- num = whnfInt;
-
- if (0<=num && num<10) { /* single digit */
- updap(0,consCharArray['0'+num],top());
- }
- else if (num<0) { /* negative integer*/
- num = -num;
- do {
- heap(1);
- topfun(consCharArray['0'+num%10]);
- } while ((num/=10)>0);
- updap(0,consCharArray['-'],top());
- }
- else { /* positive integer*/
- do {
- heap(1);
- topfun(consCharArray['0'+num%10]);
- } while ((num/=10)>9);
- updap(0,consCharArray['0'+num],top());
- }
- ret();
- }
- End
-
- static comb3(pr_ShowsFloat) /* find string rep. for float */
- { String s; /* :: Int -> Float -> ShowS */
- Int n;
- drop(); /* throw away first parameter */
- eval(pop());
- s = floatToString(floatOf(whnf));
- n = strlen(s);
- while (1<n--) {
- heap(1);
- topfun(consCharArray[s[n]]);
- }
- updap(0,consCharArray[*s],top());
- ret();
- }
- End
-
- /* --------------------------------------------------------------------------
- * Storage, initialisation and marking of primitives:
- * ------------------------------------------------------------------------*/
-
- Cell primFatbar, primFail; /* System (internal) primitives */
- Cell primUndefMem, primBlackHole;
- Cell primSel, primIf;
- Cell primStrict;
-
- Cell primPlusInt, primMinusInt; /* User (general) primitives */
- Cell primMulInt, primDivInt;
- Cell primModInt, primRemInt;
- Cell primNegInt, primQuotInt;
- Cell primCharToInt, primIntToChar;
- Cell primIntToFloat;
- Cell primPlusFloat, primMinusFloat;
- Cell primMulFloat, primDivFloat;
- Cell primNegFloat;
- Cell primEqInt, primLeInt;
- Cell primEqChar, primLeChar;
- Cell primEqFloat, primLeFloat;
- Cell primGenericEq, primGenericNe;
- Cell primGenericGt, primGenericGe;
- Cell primGenericLt, primGenericLe;
- Cell primShowsInt, primShowsFloat;
- Cell primError;
-
- #if HAS_FLOATS
- Cell primSinFloat, primAsinFloat;
- Cell primCosFloat, primAcosFloat;
- Cell primTanFloat, primAtanFloat;
- Cell primAtan2Float, primExpFloat;
- Cell primLogFloat, primLog10Float;
- Cell primSqrtFloat, primFloatToInt;
- #endif
-
- Cell primFopen; /* read from file primitive */
-
- static Void primInit() { /* initialise primitives */
- primFatbar = mkSuper(pr_FATBAR);
- primFail = mkSuper(pr_FAIL);
- primUndefMem = mkSuper(pr_UNDEFMEM);
- primBlackHole = mkSuper(pr_BlackHole);
- primSel = mkSuper(pr_SEL);
- primIf = mkSuper(pr_IF);
- primStrict = mkSuper(pr_STRICT);
- primPlusInt = mkSuper(pr_PlusInt);
- primMinusInt = mkSuper(pr_MinusInt);
- primMulInt = mkSuper(pr_MulInt);
- primDivInt = mkSuper(pr_DivInt);
- primQuotInt = mkSuper(pr_QuotInt);
- primModInt = mkSuper(pr_ModInt);
- primRemInt = mkSuper(pr_RemInt);
- primNegInt = mkSuper(pr_NegInt);
- primCharToInt = mkSuper(pr_CharToInt);
- primIntToChar = mkSuper(pr_IntToChar);
- primIntToFloat = mkSuper(pr_IntToFloat);
- primPlusFloat = mkSuper(pr_PlusFloat);
- primMinusFloat = mkSuper(pr_MinusFloat);
- primMulFloat = mkSuper(pr_MulFloat);
- primDivFloat = mkSuper(pr_DivFloat);
- primNegFloat = mkSuper(pr_NegFloat);
- primEqInt = mkSuper(pr_EqInt);
- primLeInt = mkSuper(pr_LeInt);
- primEqChar = mkSuper(pr_EqChar);
- primLeChar = mkSuper(pr_LeChar);
- primEqFloat = mkSuper(pr_EqFloat);
- primLeFloat = mkSuper(pr_LeFloat);
- primGenericEq = mkSuper(pr_GenericEq);
- primGenericNe = mkSuper(pr_GenericNe);
- primGenericGt = mkSuper(pr_GenericGt);
- primGenericGe = mkSuper(pr_GenericGe);
- primGenericLt = mkSuper(pr_GenericLt);
- primGenericLe = mkSuper(pr_GenericLe);
- primShowsInt = mkSuper(pr_ShowsInt);
- primShowsFloat = mkSuper(pr_ShowsFloat);
- primError = mkSuper(pr_Error);
- primInput = mkSuper(pr_Input);
- primFopen = mkSuper(pr_Fopen);
- #if HAS_FLOATS
- primSinFloat = mkSuper(pr_SinFloat);
- primAsinFloat = mkSuper(pr_AsinFloat);
- primCosFloat = mkSuper(pr_CosFloat);
- primAcosFloat = mkSuper(pr_AcosFloat);
- primTanFloat = mkSuper(pr_TanFloat);
- primAtanFloat = mkSuper(pr_AtanFloat);
- primAtan2Float = mkSuper(pr_Atan2Float);
- primExpFloat = mkSuper(pr_ExpFloat);
- primLogFloat = mkSuper(pr_LogFloat);
- primLog10Float = mkSuper(pr_Log10Float);
- primSqrtFloat = mkSuper(pr_SqrtFloat);
- primFloatToInt = mkSuper(pr_FloatToInt);
- #endif
- }
-
- static Void primMark() { /* mark primitives */
- mark(primFatbar);
- mark(primFail);
- mark(primUndefMem);
- mark(primBlackHole);
- mark(primSel);
- mark(primIf);
- mark(primStrict);
- mark(primPlusInt);
- mark(primMinusInt);
- mark(primMulInt);
- mark(primDivInt);
- mark(primQuotInt);
- mark(primModInt);
- mark(primRemInt);
- mark(primNegInt);
- mark(primCharToInt);
- mark(primIntToChar);
- mark(primIntToFloat);
- mark(primPlusFloat);
- mark(primMinusFloat);
- mark(primMulFloat);
- mark(primDivFloat);
- mark(primNegFloat);
- mark(primEqInt);
- mark(primLeInt);
- mark(primEqChar);
- mark(primLeChar);
- mark(primEqFloat);
- mark(primLeFloat);
- mark(primGenericEq);
- mark(primGenericNe);
- mark(primGenericGt);
- mark(primGenericGe);
- mark(primGenericLt);
- mark(primGenericLe);
- mark(primShowsInt);
- mark(primShowsFloat);
- mark(primError);
- mark(primInput);
- mark(primFopen);
- #if HAS_FLOATS
- mark(primSinFloat);
- mark(primAsinFloat);
- mark(primCosFloat);
- mark(primAcosFloat);
- mark(primTanFloat);
- mark(primAtanFloat);
- mark(primAtan2Float);
- mark(primExpFloat);
- mark(primLogFloat);
- mark(primLog10Float);
- mark(primSqrtFloat);
- mark(primFloatToInt);
- #endif
- }
-
- /* --------------------------------------------------------------------------
- * Main program including startup code and initialisation:
- *